home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / time.lisp < prev    next >
Lisp/Scheme  |  1992-08-28  |  5KB  |  157 lines
  1. (in-package "PCL")
  2.  
  3. (proclaim '(optimize (speed 3)(safety 0)(compilation-speed 0)))
  4.  
  5. (defvar *tests*)
  6. (setq *tests* nil)
  7.  
  8. (defvar m (car (generic-function-methods #'shared-initialize)))
  9. (defvar gf #'shared-initialize)
  10. (defvar c (find-class 'standard-class))
  11.  
  12. (defclass str ()
  13.   ((slot :initform nil :reader str-slot))
  14.   (:metaclass structure-class))
  15.  
  16. (defvar str (make-instance 'str))
  17.  
  18.  
  19. (push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (standard)"
  20.         '(time-slot-value m 'plist 10000))
  21.       *tests*)
  22. (push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (standard)"
  23.         '(time-slot-value m 'generic-function 10000))
  24.       *tests*)
  25. (push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (structure)"
  26.         '(time-slot-value str 'slot 10000))
  27.       *tests*)
  28. (defun time-slot-value (object slot-name n)
  29.   (time (dotimes (i n) (slot-value object slot-name))))
  30.  
  31.  
  32. (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)"
  33.         '(time-slot-value-function m 10000))
  34.       *tests*)
  35. (defun time-slot-value-function (object n)
  36.   (time (dotimes (i n) (slot-value object 'function))))
  37.  
  38.  
  39. (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)"
  40.         '(time-slot-value-slot str 10000))
  41.       *tests*)
  42. (defun time-slot-value-slot (object n)
  43.   (time (dotimes (i n) (slot-value object 'slot))))
  44.  
  45.  
  46. (push (cons "Time one-class dfun."
  47.         '(time-generic-function-methods gf 10000))
  48.       *tests*)
  49. (defun time-generic-function-methods (object n)
  50.   (time (dotimes (i n) (generic-function-methods object))))
  51.  
  52.  
  53. (push (cons "Time one-index dfun."
  54.         '(time-class-precedence-list c 10000))
  55.       *tests*)
  56. (defun time-class-precedence-list (object n)
  57.   (time (dotimes (i n) (class-precedence-list object))))
  58.  
  59.  
  60. (push (cons "Time n-n dfun."
  61.         '(time-method-function m 10000))
  62.       *tests*)
  63. (defun time-method-function (object n)
  64.   (time (dotimes (i n) (method-function object))))
  65.  
  66.  
  67. (push (cons "Time caching dfun."
  68.         '(time-class-slots c 10000))
  69.       *tests*)
  70. (defun time-class-slots (object n)
  71.   (time (dotimes (i n) (class-slots object))))
  72.  
  73.  
  74. (push (cons "Time typep for classes."
  75.         '(time-typep-standard-object m 10000))
  76.       *tests*)
  77. (defun time-typep-standard-object (object n)
  78.   (time (dotimes (i n) (typep object 'standard-object))))
  79.  
  80.  
  81. (push (cons "Time default-initargs."
  82.         '(time-default-initargs (find-class 'plist-mixin) 1000))
  83.       *tests*)
  84. (defun time-default-initargs (class n)
  85.   (time (dotimes (i n) (default-initargs class nil))))
  86.  
  87.  
  88. (push (cons "Time make-instance."
  89.         '(time-make-instance (find-class 'plist-mixin) 1000))
  90.       *tests*)
  91. (defun time-make-instance (class n)
  92.   (time (dotimes (i n) (make-instance class))))
  93.  
  94. (push (cons "Time constant-keys make-instance."
  95.         '(time-constant-keys-make-instance 1000))
  96.       *tests*)
  97.  
  98. (expanding-make-instance-top-level
  99. (defun constant-keys-make-instance (n)
  100.   (dotimes (i n) (make-instance 'plist-mixin))))
  101.  
  102. (precompile-random-code-segments)
  103.  
  104. (defun time-constant-keys-make-instance (n)
  105.   (time (constant-keys-make-instance n)))
  106.  
  107. (defun expand-all-macros (form)
  108.   (walk-form form nil #'(lambda (form context env)
  109.               (if (and (eq context :eval)
  110.                    (consp form)
  111.                    (symbolp (car form))
  112.                    (not (special-form-p (car form)))
  113.                    (macro-function (car form)))
  114.                   (values (macroexpand form env))
  115.                   form))))
  116.  
  117. (push (cons "Macroexpand meth-structure-slot-value"
  118.         '(pprint (multiple-value-bind (pgf pm)
  119.              (prototypes-for-make-method-lambda 
  120.               'meth-structure-slot-value)
  121.                (expand-defmethod
  122.             'meth-structure-slot-value pgf pm
  123.             nil '((object str))
  124.             '(#'(lambda () (slot-value object 'slot)))
  125.             nil))))
  126.       *tests*)
  127.  
  128. #-kcl
  129. (push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)."
  130.         '(disassemble (meth-structure-slot-value str)))
  131.       *tests*)
  132. (defmethod meth-structure-slot-value ((object str))
  133.   #'(lambda () (slot-value object 'slot)))
  134.  
  135.  
  136. #|| ; interesting, but long.  (produces 100 lines of output)
  137. (push (cons "Macroexpand meth-standard-slot-value"
  138.         '(pprint (expand-all-macros
  139.              (expand-defmethod-internal 'meth-standard-slot-value
  140.               nil '((object standard-method))
  141.               '(#'(lambda () (slot-value object 'function)))
  142.               nil))))
  143.       *tests*)
  144. (push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)."
  145.         '(disassemble (meth-standard-slot-value m)))
  146.       *tests*)
  147. (defmethod meth-standard-slot-value ((object standard-method))
  148.   #'(lambda () (slot-value object 'function)))
  149. ||#
  150.  
  151.  
  152. (defun do-tests ()
  153.   (dolist (doc+form (reverse *tests*))
  154.     (format t "~&~%~A~%" (car doc+form))    
  155.     (pprint (cdr doc+form))
  156.     (eval (cdr doc+form))))
  157.